home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / annotation-parser.scm next >
Encoding:
Text File  |  1994-09-27  |  8.3 KB  |  252 lines  |  [TEXT/CCL2]
  1.  
  2. (define *annotation-escape* '())
  3.  
  4. (define (parse-annotations context)
  5.  (let ((save-layout (dynamic *layout-stack*)))
  6.   (setf (dynamic *layout-stack*) '())
  7.   (advance-token)
  8.   (let/cc annotation-escape
  9.    (setf *annotation-escape* (lambda () 
  10.                    (setf (dynamic *layout-stack*) save-layout)
  11.                    (advance-to-annotation-end)
  12.                    (funcall annotation-escape '())))
  13.    (let ((res (start-layout (lambda (in-layout?)
  14.                   (parse-annotation-list-1 in-layout? context)))))
  15.     (setf (dynamic *layout-stack*) save-layout)
  16.     (token-case
  17.      (end-annotation res)
  18.      (else (signal-annotation-error)))))))
  19.  
  20. (define (parse-annotation-list-1 in-layout? context)
  21.   (let ((kind (get-annotation-kind)))
  22.     (cond ((eq? kind 'decl)
  23.        (let ((d (parse-annotation-decl context)))
  24.          (token-case
  25.           (\; (cons d (parse-annotation-list-1 in-layout? context)))
  26.           (else (close-layout in-layout?)
  27.             (list d)))))
  28.       ((eq? kind 'value)
  29.        (let ((d (parse-annotation-value context 'val)))
  30.          (token-case
  31.           (\; (cons d (parse-annotation-list-1 in-layout? context)))
  32.           (else (close-layout in-layout?)
  33.             (list d)))))
  34.       (else
  35.        (close-layout in-layout?)
  36.        '()))))
  37.  
  38. (define (get-annotation-kind)
  39.   (token-case
  40.    ((no-advance end-annotation) 'end)
  41.    ((no-advance \() 'decl)
  42.    ((var con)
  43.     (let ((next (peek-1-type)))
  44.       (cond ((eq? next '|,|)
  45.          'decl)
  46.         ((eq? next '|::|)
  47.          'decl)
  48.         (else
  49.          'value))))
  50.    (else 'error)))
  51.  
  52. (define (parse-annotation-decl context)
  53.   (let* ((names (parse-aname-list))
  54.      (decls (parse-aval-list context)))
  55.     (make annotation-decl (names names) (annotations decls))))
  56.  
  57. (define (parse-aname-list)
  58.  (let ((name 'foo))
  59.   (token-case
  60.    (var
  61.     (setf name (var->symbol)))
  62.    (con
  63.     (setf name (con->symbol)))
  64.    (else (signal-annotation-error)))
  65.   (token-case (\, (cons name (parse-aname-list)))
  66.           (|::| (list name))
  67.           (else (signal-annotation-error)))))
  68.  
  69.  
  70. (define (parse-aval-list context)
  71.   (let ((ann (parse-annotation-value context 'decl)))
  72.     (token-case (\, (cons ann (parse-aval-list context)))
  73.         (else (list ann)))))
  74.  
  75. (define (parse-annotation-value context type)
  76.   (token-case
  77.    (name (mlet ((name (token->symbol))
  78.         ((arg-types place ty) (get-annotation-description name))
  79.         (args (parse-annotation-args name arg-types)))
  80.        (unless (eq? type ty)
  81.           (if (eq? ty 'decl)
  82.           (signal-annotation-needs-decl-error name)
  83.           (signal-annotation-is-value-error name)))
  84.        (unless (memq context place)
  85.                (signal-annotation-place-error name))
  86.        (make annotation-value (name name) (args args))))))
  87.  
  88. (define (parse-annotation-args name types)
  89.  (if (null? types)
  90.      (token-case
  91.       (\( (signal-annotation-arg-error name))
  92.       (else '()))
  93.      (token-case
  94.       (\( (parse-annotation-args-1 name types))
  95.       (else (signal-annotation-arg-error name)))))
  96.  
  97. ;;; This routine can invoke special parsers for the arguments
  98.  
  99. (define (parse-annotation-args-1 name types)
  100.   (if (null? types)
  101.       (signal-annotation-arg-error name)
  102.       (let ((arg (parse-annotation-arg (car types) name)))
  103.     (token-case
  104.      (\) (if (null? (cdr types))
  105.          (list arg)
  106.          (signal-annotation-arg-error name)))
  107.      (\, (cons arg (parse-annotation-args-1 name (cdr types))))
  108.      (else (signal-annotation-arg-error name))))))
  109.  
  110. (define (parse-annotation-arg type name)
  111.   (cond ((eq? type 'string)
  112.      (token-case
  113.       ((string no-advance)
  114.        (let ((res (car *token-args*)))
  115.          (advance-token)
  116.          res))
  117.       (else (signal-annotation-arg-error name))))
  118.     ;; The following is for a datatype import/export.  It is
  119.     ;; Type(Con1(strs),Con2(strs),...)
  120.     ((eq? type 'integer)
  121.      (token-case
  122.       ((integer no-advance) (token->integer))
  123.       (else (signal-annotation-arg-error name))))
  124.     ((eq? type 'constr-list)
  125.      (parse-annotation-constr-list name))
  126.     ((eq? type 'signature)
  127.      (parse-signature))
  128.     (else
  129.      (signal-annotation-error))))
  130.        
  131. (define (parse-annotation-constr-list name)
  132.   (token-case
  133.    (tycon (let ((type-name (token->symbol)))
  134.         (token-case (\( (let* ((args (parse-acl1 name))
  135.                    (res (tuple type-name args)))
  136.                   (token-case  ; leave the close to end the args
  137.                    ((no-advance \)) (list res))
  138.                    (\, (cons res
  139.                      (parse-annotation-constr-list name)))
  140.                    (else (signal-annotation-arg-error name)))))
  141.             (else (signal-annotation-arg-error name)))))
  142.    (else (signal-annotation-arg-error name))))
  143.  
  144. (define (parse-acl1 name)
  145.   (token-case
  146.    (con (let ((con-name (con->symbol)))
  147.       (token-case (\( (let ((str-args (parse-string-list name)))
  148.                 (token-case
  149.                  (\, (cons (tuple con-name str-args)
  150.                        (parse-acl1 name)))
  151.                  (\) (list (tuple con-name str-args)))
  152.                  (else (signal-annotation-arg-error name)))))
  153.               (else (signal-annotation-arg-error name)))))
  154.    (else (signal-annotation-arg-error name))))
  155.  
  156. (define (parse-string-list name)
  157.   (token-case
  158.    ((string no-advance)
  159.     (let ((res (read-lisp-object (car *token-args*))))
  160.       (advance-token)
  161.       (token-case
  162.        (\) (list res))
  163.        (\, (cons res (parse-string-list name)))
  164.        (else (signal-annotation-arg-error name)))))
  165.    (else (signal-annotation-arg-error name))))
  166.  
  167. (define (advance-to-annotation-end)
  168.   (token-case
  169.    (eof '())
  170.    (end-annotation
  171.      '())
  172.    (else
  173.     (advance-token)
  174.     (advance-to-annotation-end))))
  175.   
  176. ;;; This table is used to check the syntax of all annotation declarations.
  177. ;;; There are two parts to the syntax: the annotation arguments and the
  178. ;;; placement of the annotation.  Each annotation is described by a triple:
  179. ;;;  argument-types, place, kind.
  180. ;;; The argument types are a list corresponding to the type of each annotation
  181. ;;; argument.  Types are:
  182. ;;;    string
  183. ;;;    constr-list - used in import-lisp-type, export-lisp-type
  184. ;;;    integer
  185. ;;;    signature  - used in specialize
  186. ;;; The places are
  187. ;;;    interface  - an interface file
  188. ;;;    decl       - part of an inner decl list
  189. ;;;    topdecl    - a top level declaration
  190. ;;;    constructor - associated with a constructor slot in a type decl
  191. ;;; The kinds are
  192. ;;;    val  - the annotation appears by itself
  193. ;;;    decl - the annotation is associated with a list of variables using ::
  194.  
  195. (define *known-annotations* '(
  196.   (|LispName| (args string) (place interface) (kind decl))
  197.   (|CName| (args string) (place interface) (kind decl))
  198.   (|Prelude| (args) (place topdecl interface) (kind val))
  199.   (|Strictness| (args string) (place topdecl interface decl) (kind decl))
  200. ;  (|Strict| (args) (place constructor) (kind val))  - I think this is a bug!
  201.   (|NoConversion| (args) (place interface) (kind decl))
  202.   (|Inline| (args) (place topdecl decl) (kind decl))
  203.   (|AlwaysInline| (args) (place topdecl decl) (kind decl))
  204.   (|STRICT| (args) (place constructor) (kind val))
  205.   (|ImportLispType| (args constr-list) (place topdecl interface) (kind val))
  206.   (|ExportLispType| (args constr-list) (place topdecl interface) (kind val))
  207.   (|Complexity| (args integer) (place interface topdecl decl) (kind decl))
  208.   (|Specialize| (args signature) (place topdecl decl) (kind decl))
  209.   ))
  210.  
  211. (define (get-annotation-description annotation)
  212.   (let ((s (assq annotation *known-annotations*)))
  213.     (cond ((eq? s '#f)
  214.        (parser-error/recoverable 'unknown-annotation
  215. "Annotation ~A is not defined in this system.~%Annotation comment ignored."
  216.            annotation)
  217.        (funcall *annotation-escape*))
  218.       (else
  219.        (values (tuple-2-2 (assq 'args (tuple-2-2 s)))
  220.            (tuple-2-2 (assq 'place (tuple-2-2 s)))
  221.            (car (tuple-2-2 (assq 'kind (tuple-2-2 s)))))))))
  222.  
  223. (define (signal-annotation-error)
  224.   (parser-error/recoverable 'annotation-error
  225.      "Annotation syntax error"))
  226.  
  227. (define (signal-annotation-arg-error name)
  228.   (parser-error/recoverable 'annotation-error
  229.      "Annotation syntax error: arguments to the ~A annotation are incorrect"
  230.       name)
  231.   (funcall *annotation-escape*))
  232.  
  233. (define (signal-annotation-place-error name)
  234.   (parser-error/recoverable 'annotation-error
  235.      "Annotation syntax error: the ~A annotation is not valid in this context"
  236.       name)
  237.   (funcall *annotation-escape*))
  238.  
  239. (define (signal-annotation-needs-decl-error name)
  240.   (parser-error/recoverable 'annotation-error
  241. "Annotation syntax error: the ~A annotation must be attached to names using ::"
  242.       name)
  243.   (funcall *annotation-escape*))
  244.  
  245. (define (signal-annotation-is-value-error name)
  246.   (parser-error/recoverable 'annotation-error
  247.      "Annotation syntax error: ~A cannot be associated with names using ::"
  248.       name)
  249.   (funcall *annotation-escape*))
  250.  
  251.  
  252.